(DECLARE (SPECIAL **EXP** **UNEVLIS** **ENV** **EVLIS** **PC** **CLINK** **VAL** **TEM**
                     **TOP** **QUEUE** **TICK** **PROCESS** **QUANTUM**
                     VERSION LISPVERSION))

(DEFUN VERSION MACRO (X)
       (COND (COMPILER-STATE (LIST 'QUOTE (STATUS UREAD)))
	     (T (RPLACA X 'QUOTE)
		(RPLACD X (LIST VERSION))
		(LIST 'QUOTE VERSION))))

(DECLARE (READ))

(SETQ VERSION ((LAMBDA (COMPILER-STATE) (VERSION)) T))

(DEFUN SCHEME ()
       (SETQ VERSION (VERSION)  LISPVERSION (STATUS LISPVERSION))
       (TERPRI)
       (PRINC '|THIS IS SCHEME |)
       (PRINC VERSION)
       (PRINC '| RUNNING IN LISP |)
       (PRINC LISPVERSION)
       (SETQ **ENV** NIL  **QUEUE** NIL
             **PROCESS** (CREATE!PROCESS '(**TOP** '|SCHEME -- TOPLEVEL|)))
       (SWAPINPROCESS)
       (ALARMCLOCK 'RUNTIME **QUANTUM**)
       (MLOOP))

(SETQ **TOP**
      '(BETA (LAMBDA (**MESSAGE**)
                (LABELS ((**TOP1**
                          (LAMBDA (**IGNORE1** **IGNORE2** **IGNORE3**)
                             (**TOP1** (TERPRI) (PRINC '|==> |)
                                       (PRINT (SET '* (EVALUATE (READ))))))))
                    (**TOP1** (TERPRI) (PRINC **MESSAGE**) NIL)))
             NIL))

(DEFUN SETTICK (X) (SETQ **TICK** T))

(SETQ **QUANTUM** 1000000.  ALARMCLOCK 'SETTICK)

(DEFUN MLOOP ()
       (DO ((**TICK** NIL)) (NIL)	;DO forever
	   (AND **TICK** (ALLOW) (SCHEDULE))
	   (FASTCALL **PC**)))

(DEFUN FASTCALL (ATSYM)
       (COND ((EQ (CAR (CDR ATSYM)) 'SUBR)
	      (SUBRCALL NIL (CADR (CDR ATSYM))))
	     (T ((LAMBDA (SUBR)
			 (COND (SUBR (REMPROP ATSYM 'SUBR)
				     (PUTPROP ATSYM SUBR 'SUBR)
				     (SUBRCALL NIL SUBR))
			       (T (APPLY ATSYM NIL))))
		 (GET ATSYM 'SUBR)))))

(DEFUN ALLOW ()
       ((LAMBDA (VCELL)
		(COND (VCELL (CADR VCELL))
		      (T T)))
	(ASSQ '*ALLOW* **ENV**)))

(DEFUN SCHEDULE ()
       ((LAMBDA (OLDINT)
                (COND (**QUEUE**
                       (SWAPOUTPROCESS)
                       (NCONC **QUEUE** (LIST **PROCESS**))
                       (SETQ **PROCESS** (CAR **QUEUE**)
                             **QUEUE** (CDR **QUEUE**))
                       (SWAPINPROCESS)))
                (SETQ **TICK** NIL)
                (ALARMCLOCK 'RUNTIME **QUANTUM**)
                (NOINTERRUPT OLDINT))
        (NOINTERRUPT T)))

(DEFUN SWAPOUTPROCESS ()
       ((LAMBDA (**CLINK**)
                (PUTPROP **PROCESS** (SAVEUP **PC**) 'CLINK)
                (PUTPROP **PROCESS** **VAL** 'VAL))
        **CLINK**))

(DEFUN SWAPINPROCESS () 
       (SETQ **CLINK** (GET **PROCESS** 'CLINK)
             **VAL** (GET **PROCESS** 'VAL))
       (RESTORE))

(DEFUN PRIMOP (X) (GETL X '(SUBR EXPR LSUBR)))

(DEFUN SAVEUP (RETAG)
       (SETQ **CLINK** (LIST **EXP** **UNEVLIS** **ENV** **EVLIS** RETAG **CLINK**)))

(DEFUN RESTORE ()
  (PROG (TEMP)
       (SETQ TEMP (OR **CLINK**
		     (ERROR '|PROCESS RAN OUT - RESTORE|
			     **EXP**
			     'FAIL-ACT))
             **EXP** (CAR TEMP)
              TEMP (CDR TEMP)
             **UNEVLIS** (CAR TEMP)
              TEMP (CDR TEMP)
             **ENV** (CAR TEMP)
              TEMP (CDR TEMP)
             **EVLIS** (CAR TEMP)
              TEMP (CDR TEMP)
             **PC** (CAR TEMP)
              TEMP (CDR TEMP)
             **CLINK** (CAR TEMP))))

(DEFUN AEVAL ()
       (COND ((ATOM **EXP**)
              (COND ((NUMBERP **EXP**)
                     (SETQ **VAL** **EXP**)
                     (RESTORE))
                    ((PRIMOP **EXP**)
                     (SETQ **VAL** **EXP**)
                     (RESTORE))
                    ((SETQ **TEM** (ASSQ **EXP** **ENV**))
                     (SETQ **VAL** (CADR **TEM**))
                     (RESTORE))
                    (T (SETQ **VAL** (SYMEVAL **EXP**))
                       (RESTORE))))
             ((ATOM (CAR **EXP**))
              (COND ((SETQ **TEM** (GET (CAR **EXP**) 'AINT))
                     (SETQ **PC** **TEM**))
                    ((EQ (CAR **EXP**) 'LAMBDA)
                     (SETQ **VAL** (LIST 'BETA **EXP** **ENV**))
                     (RESTORE))
                    ((SETQ **TEM** (GET (CAR **EXP**) 'AMACRO))
                     (SETQ **EXP** (FUNCALL **TEM** **EXP**)))
                    (T (SETQ **EVLIS** NIL
                             **UNEVLIS** **EXP**
                             **PC** 'EVLIS))))
             ((EQ (CAAR **EXP**) 'LAMBDA)
              (SETQ **EVLIS** (LIST (CAR **EXP**))
                    **UNEVLIS** (CDR **EXP**)
                    **PC** 'EVLIS))
             (T (SETQ **EVLIS** NIL
                      **UNEVLIS** **EXP**
                      **PC** 'EVLIS))))

(DEFUN EVLIS ()
       (COND ((NULL **UNEVLIS**)
              (SETQ **EVLIS** (REVERSE **EVLIS**))
              (COND ((ATOM (CAR **EVLIS**))
	             (SETQ **VAL** (APPLY (CAR **EVLIS**) (CDR **EVLIS**)))
	             (RESTORE))
                    ((EQ (CAAR **EVLIS**) 'LAMBDA)
                     (SETQ **ENV** (PAIRLIS (CADAR **EVLIS**) (CDR **EVLIS**) **ENV**)
                           **EXP** (CADDAR **EVLIS**)
                           **PC** 'AEVAL))
                    ((EQ (CAAR **EVLIS**) 'BETA)
                     (SETQ **ENV** (PAIRLIS (CADR (CADAR **EVLIS**))
                                            (CDR **EVLIS**)
                                            (CADDAR **EVLIS**))
                           **EXP** (CADDR (CADAR **EVLIS**))
                           **PC** 'AEVAL))
                    ((EQ (CAAR **EVLIS**) 'DELTA)
                     (SETQ **CLINK** (CADAR **EVLIS**))
                    (RESTORE))
                    (T (ERROR '|BAD FUNCTION - EVARGLIST| **EXP** 'FAIL-ACT))))
             (T (SAVEUP 'EVLIS1)
                (SETQ **EXP** (CAR **UNEVLIS**)
                      **PC** 'AEVAL))))

(DEFUN EVLIS1 ()
       (SETQ **EVLIS** (CONS **VAL** **EVLIS**)
             **UNEVLIS** (CDR **UNEVLIS**)
             **PC** 'EVLIS))

(DEFPROP EVALUATE EVALUATE AINT)

(DEFUN EVALUATE ()
       (SAVEUP 'EVALUATE1)
       (SETQ **EXP** (CADR **EXP**)
	     **PC** 'AEVAL))

(DEFUN EVALUATE1 ()
       (SETQ **EXP** **VAL**
	     **PC** 'AEVAL))

(DEFPROP IF IF AINT)

(DEFUN IF ()
       (SAVEUP 'IF1)
       (SETQ **EXP** (CADR **EXP**)
             **PC** 'AEVAL))

(DEFUN IF1 ()
       (COND (**VAL** (SETQ **EXP** (CADDR **EXP**)))
             (T (SETQ **EXP** (CADDDR **EXP**))))
       (SETQ **PC** 'AEVAL))

(DEFPROP QUOTE AQUOTE AINT)

(DEFUN AQUOTE ()
       (SETQ **VAL** (CADR **EXP**))
       (RESTORE))

(DEFPROP LABELS LABELS AINT)

(DEFUN LABELS ()
       (SETQ **TEM** (MAPCAR '(LAMBDA (DEF)
                                  (LIST (CAR DEF)
                                        (LIST 'BETA (CADR DEF) NIL)))
                         (CADR **EXP**)))
       (MAPC '(LAMBDA (VC) (RPLACA (CDDADR VC) **TEM**)) **TEM**)
       (SETQ **ENV** (NCONC **TEM** **ENV**)
             **EXP** (CADDR **EXP**)
             **PC** 'AEVAL))

(DEFUN CREATE!PROCESS (EXP)
      ((LAMBDA (**PROCESS** **EXP** **ENV** **UNEVLIS** **EVLIS** **PC** **CLINK** **VAL**)
               (SWAPOUTPROCESS)
               **PROCESS**)
       (GENSYM)
       EXP
       **ENV**
       NIL
       NIL
       'AEVAL
       (LIST NIL NIL NIL NIL 'TERMINATE NIL)
       NIL))

(DEFUN START!PROCESS (P)
      (COND ((OR (NOT (ATOM P)) (NOT (GET P 'CLINK)))
             (ERROR '|BAD PROCESS -- START!PROCESS| **EXP** 'FAIL-ACT)))
      ((LAMBDA (OLDINT)
               (OR (EQ P **PROCESS**) (MEMQ P **QUEUE**)
                   (SETQ **QUEUE** (NCONC **QUEUE** (LIST P))))
               (NOINTERRUPT OLDINT))
       (NOINTERRUPT T))
      P)

(DEFUN STOP!PROCESS (P)
      (COND ((MEMQ P **QUEUE**)
             ((LAMBDA (OLDINT)
                      (SETQ **QUEUE** (DELETE P **QUEUE**))
                      (NOINTERRUPT OLDINT))
              (NOINTERRUPT T)))
            ((EQ P **PROCESS**) (TERMINATE)))
      P)

(DEFUN TERMINATE ()
       ((LAMBDA (OLDINT)
                (COND ((NULL **QUEUE**)
                       (SETQ **PROCESS**
                             (CREATE!PROCESS '(**TOP** '|SCHEME -- QUEUEOUT|))))
                      (T (SETQ **PROCESS** (CAR **QUEUE**)
			       **QUEUE** (CDR **QUEUE**))))
                (setq **clink** (get **process** 'clink))
                (setq **val** (get **process** 'val))
                (NOINTERRUPT OLDINT)
                'TERMINATE-VALUE)
        (NOINTERRUPT T)))

(DEFPROP EVALUATE!UNINTERRUPTIBLY EVALUATE!UNINTERRUPTIBLY AINT)

(DEFUN EVALUATE!UNINTERRUPTIBLY ()
       (SETQ **ENV** (CONS (LIST '*ALLOW* NIL) **ENV**)
	     **EXP** (CADR **EXP**)
	     **PC** 'AEVAL))

(DEFPROP DEFINE DEFINE AINT)

(DEFUN DEFINE ()
       (SET (CADR **EXP**) (LIST 'BETA (CADDR **EXP**) NIL))
       (SETQ **VAL** (CADR **EXP**))
       (RESTORE))

(DEFUN ASET (VAR VALU)
       (SETQ **TEM** (ASSQ VAR **ENV**))
       (OR **TEM** (ERROR '|CAN'T SET UNBOUND VARIABLE - SET|
		       (LIST 'ASET VAR VALU)
		       'FAIL-ACT))
       (RPLACA (CDR **TEM**) VALU)
       VALU)

(DEFPROP CATCH ACATCH AINT)

(DEFUN ACATCH ()
       (SETQ **ENV** (CONS (LIST (CADR **EXP**) (LIST 'DELTA **CLINK**)) **ENV**)
             **EXP** (CADDR **EXP**)
             **PC** 'AEVAL))

(DEFUN PAIRLIS (X Y Z)
       (DO ((I X (CDR I))
            (J Y (CDR J))
            (L Z (CONS (LIST (CAR I) (CAR J)) L)))
           ((AND (NULL I) (NULL J)) L)
          (AND (OR (NULL I) (NULL J))
               (ERROR '|WRONG NUMBER OF ARGUMENTS - PAIRLIS|
		      **EXP** 
		      'WRNG-NO-ARGS))))

ββββ